home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / debugger.f83 < prev    next >
Text File  |  1991-09-14  |  4KB  |  186 lines
  1. \
  2. \  FORTH DEBUGGER DEFINITIONS
  3. \
  4. \  Copyright (C) 1988-1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 30 June 1988
  15. \
  16. \  Last updated on: 6 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, string, compiler, structures, blocks, lists
  20. \
  21. \  Description:
  22. \       Basic debugging function built on a general advice function
  23. \       management. Allows black-box tracing, break points and
  24. \       colon definitions call profiling. The break point command
  25. \       loop is a copy of interpret and a set of commands for
  26. \       investigating the state of the program may be used.
  27. \
  28. \  Copying:
  29. \       This program is free software; you can redistribute it and\or modify
  30. \       it under the terms of the GNU General Public License as published by
  31. \       the Free Software Foundation; either version 1, or (at your option)
  32. \       any later version.
  33. \
  34. \       This program is distributed in the hope that it will be useful,
  35. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  36. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  37. \       GNU General Public License for more details.
  38. \
  39. \       You should have received a copy of the GNU General Public License
  40. \       along with this program; see the file COPYING.  If not, write to
  41. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  42.  
  43. .( Loading Debugger definitions...) cr
  44.  
  45. #include internals.f83
  46. #include blocks.f83
  47. #include lists.f83
  48. #include structures.f83
  49.  
  50. vocabulary debugger ( -- )
  51.  
  52. blocks structures lists string compiler forth debugger definitions
  53.  
  54. struct.type ADVICE ( -- ) private
  55.   ptr +block ( advice -- addr) private
  56.   ptr +entry ( advice -- addr) private
  57.   ptr +advice ( advice -- addr) private
  58.   long +profile ( advice -- addr) private
  59. struct.end
  60.  
  61. : [advice] ( advice -- )
  62.   dup +advice @ execute
  63. ; private
  64.  
  65. : .s ( -- )
  66.   ." [" depth 0 .r ." ] "
  67.   depth 5 > if ." \... " then
  68.   depth 5 min 0 swap ?do ." \" i pick . -1 +loop
  69. ;
  70.  
  71. : [colon] ( advice -- )
  72.   1 over +profile +!
  73.   +block @ call
  74. ; private
  75.  
  76. : [trace] ( advice -- )
  77.   ." --> " dup >r +entry @ .name .s cr
  78.   r@ [colon]
  79.   ." <-- " r> +entry @ .name .s cr
  80. ; private
  81.  
  82. : *abort* ( -- )
  83.   r> drop
  84.   .s ." Abort: " r> +entry @ .name cr
  85.   abort
  86. ;
  87.  
  88. : *return* ( -- )
  89.   r> drop
  90.   .s ." Return: " r> +entry @ .name cr
  91. ;
  92.  
  93. : *call* ( -- )
  94.   r> drop
  95.   .s ." Call: " r@ +entry @ .name cr
  96.   r@ [colon]
  97.   .s ." Return: " r> +entry @ .name cr
  98. ;
  99.   
  100. : *execute* ( -- )
  101.   .s ." Execute: "
  102.   r> r@ swap >r
  103.   dup +entry @ .name cr
  104.   [colon]
  105.   r> r@ swap >r >r
  106.   .s ." Break: " r> +entry @ .name cr
  107. ;
  108.  
  109. : *profile* ( -- )
  110.   .s ." Profile: "
  111.   r> r@ swap >r
  112.   dup +entry @ .name space ." calls: " +profile @ . cr
  113. ;
  114.  
  115. : [break] ( advice -- )
  116.   >r .s ." Break: " r@ +entry @ .name cr
  117.   begin
  118.     32 word
  119.     find ?dup
  120.     if compiling = 
  121.       if thread else execute then
  122.     else
  123.       recognize
  124.       if [compile] literal
  125.       else
  126.     $print abort" ?? Break Point Aborted"
  127.       then
  128.     then
  129.   again
  130. ; private
  131.  
  132. : tail-recurse ( -- )
  133.   compile (branch)
  134.   last >body +block @ <resolve
  135. ; compilation immediate
  136.  
  137. : ?advice ( entry -- bool)
  138.   +code @ ['] [advice] >body =
  139. ;
  140.  
  141. : advice ( action -- )
  142.   ' dup ?advice not
  143.   abort" advice: not an adviced definition"
  144.   >body 0 over +profile ! +advice !
  145. ;
  146.  
  147. : colon ( -- )
  148.   ['] [colon] advice
  149. ;
  150.  
  151. : trace ( -- )
  152.   ['] [trace] advice
  153. ;
  154.  
  155. : break ( -- )
  156.   ['] [break] advice
  157. ;
  158.  
  159. : .profile ( -- )
  160.   5 spaces ." Calls"
  161.   1 spaces ." Function" cr
  162.   last
  163.   block[ ( entry -- )
  164.     dup ?advice
  165.     if dup >body +profile @
  166.       10 .r space
  167.       .name cr
  168.     else
  169.       drop
  170.     then
  171.   ]; map-list
  172. ;
  173.  
  174. : : ( -- )
  175.   :
  176.   new-struct ADVICE
  177.   dup last +parameter !
  178.   ['] [advice] >body last +code !
  179.   last over +entry !
  180.   ['] [colon] over +advice !
  181.   0 over +profile !
  182.   here swap +block !
  183. ;
  184.  
  185. forth only
  186.